##+##########################################################################
#
# Scotch Yoke -- Animates a Scotch Yoke
# by Keith Vetter, Feb 29, 2008
#
# http://www.mekanizmalar.com/scotch_yoke.shtml

package require Tk
if {! [catch {package require tile}]} {
    namespace import -force ::ttk::checkbutton
}

set S(help) {
    The Scotch Yoke is a mechanism for converting linear motion
    into rotary motion or vice-versa

    It has the advantage over a standard crankshaft or connecting
    rod by having higher torque, fewer moving parts, smoother
    operation and less time spent at top dead center.

    On the other hand, it wears out rapidly due to sliding friction
    and high contact pressures.
}

array set S {title "Scotch Yoke" w 730 h 400 animate 1 aid "" delay 10}

# Gear center
set V(gear,r) 120
set V(gear,clr) gray40

# Driving peg
set V(peg,r) 30
set V(peg,o) [list 0 [expr {-($V(gear,r) - $V(peg,r))}]]
set V(peg,clr) magenta

set V(rod,h) 50
set V(rod,w) 540
set V(rod,th) 20
set V(rod,clr) cyan

set V(block,sz) {30 110}
set V(block,dx) [expr {$V(rod,th) + 5}]
set V(block,clr1) \#6c664c
set V(block,clr2) \#AC863c

proc DoDisplay {} {
    global S

    wm title . $S(title)
    frame .top -bd 2 -relief ridge
    frame .bottom -bd 0
    label .title -text $S(title) -font {Times 42 bold}
    button .? -text "?" -command About
    catch {.? config -font "[font actual [.? cget -font]] -weight bold"}
    checkbutton .anim -variable S(animate) -text Animate -command Animate
    catch {.anim config -relief ridge -pady 5 -padx 5}

    canvas .c -width $S(w) -height $S(h) -bd 0 -highlightthickness 0
    bind .c <Configure> {ReCenter %W %h %w}

    pack .title -in .top -side top -fill x
    pack .c -in .top -side top -fill both -expand 1
    pack .top -side top -fill both -expand 1
    pack .bottom -side bottom -fill x -expand 1
    pack .anim -in .bottom -side left -expand 1 -pady 10
    place .? -in .bottom -relx .99 -rely .5 -anchor e
}
proc ReCenter {W h w} {                   ;# Called by configure event
    set h2 [expr {$h / 2}] ; set w2 [expr {$w / 2}]
    $W config -scrollregion [list -$w2 -$h2 $w2 $h2]
}
proc Gears {} {
    global V S

    set xy [MakeBox 0 0 $V(gear,r)]
    .c create oval $xy -fill $V(gear,clr)
    lassign $V(peg,o) x0 y0
    set xy [MakeBox $x0 $y0 $V(peg,r)]
    set xy2 [eval RegularPolygon2 $xy -start 0 -extent 360]
    .c create polygon $xy2 -tag peg -fill $V(peg,clr)
}
proc Blocks {} {
    global V

    lassign $V(block,sz) w h
    set dx $V(block,dx)

    set x1 [expr {$V(gear,r) + $dx}]
    set x2 [expr {$x1 + $w}]
    set y1 [expr {-$h/2}]
    set y2 [expr {-$V(rod,h)/2}]
    set y3 [expr {$V(rod,h)/2}]
    set y4 [expr {$h/2}]

    .c create rect $x1 $y1 $x2 $y2 -fill $V(block,clr1) -tag a
    .c create rect $x1 $y2 $x2 $y3 -fill $V(block,clr2) -tag b
    .c create rect $x1 $y3 $x2 $y4 -fill $V(block,clr1) -tag c

    .c create rect -$x1 $y1 -$x2 $y2 -fill $V(block,clr1) -tag d
    .c create rect -$x1 $y2 -$x2 $y3 -fill $V(block,clr2) -tag e
    .c create rect -$x1 $y3 -$x2 $y4 -fill $V(block,clr1) -tag f
}
proc Rod {} {
    global V

    set x1 [expr {$V(rod,w) / 2}]
    set y1 [expr {$V(rod,h) / 2}]
    set x2 [expr {$V(peg,r) + $V(rod,th)}]
    set y2 $y1
    set x3 $x2
    set y3 [expr {$V(gear,r) + $V(rod,th)}]
    set x4 [expr {-$x3}]
    set y4 [expr {$V(gear,r) - 2*$V(peg,r) - $V(rod,th)}]
    set bottom [RegularPolygon2 $x3 $y3 $x4 $y4 -start 0 -extent 180]
    set top [RegularPolygon2 $x3 -$y3 $x4 -$y4 -start 180 -extent 180]

    # outer part
    set xy1 $bottom
    lappend xy1 -$x2 $y2 -$x1 $y1
    lappend xy1 -$x1 -$y1 -$x2 -$y2
    set xy1 [concat $xy1 $top]
    lappend xy1 $x2 -$y2 $x1 -$y1
    lappend xy1 $x1 $y1 $x2 $y2
    set xy1 [concat $xy1 [lrange $bottom 0 1]]

    # inner hole
    set x5 $V(peg,r)
    set y5 $V(gear,r)
    set x6 [expr {-$V(peg,r)}]
    set y6 [expr {$V(gear,r) - 2*$V(peg,r)}]
    set bottom [RegularPolygon2 $x5 $y5 $x6 $y6 -start 180 -extent -180]
    set top [RegularPolygon2 $x5 -$y5 $x6 -$y6 -start 0 -extent -180]
    set xy2 [concat [lrange $bottom end-1 end] $top $bottom]

    # exploit winding rule drawing to get hole in the middle
    set xy [concat $xy1 $xy2]
    .c create poly $xy -tag rod -fill $V(rod,clr) -outline black

    # remove porkchop outline remnant
    set xy [concat [lrange $xy1 0 1] [lrange $xy2 0 1]]
    .c create line $xy -tag rod -fill $V(rod,clr)
}
proc MakeBox {x y r} {
    return [list [expr {$x-$r}] [expr {$y-$r}] [expr {$x+$r}] [expr {$y+$r}]]
}
# from https://wiki.tcl-lang.org/Regular%20Polygons%202
proc RegularPolygon2 {x0 y0 x1 y1 args} {
    array set V {-sides 0 -start 90 -extent 360} ;# Default values
    foreach {a value} $args {
        if {! [info exists V($a)]} {error "unknown option $a"}
        if {$value == {}} {error "value of \"$a\" missing"}
        set V($a) $value
    }
    if {$V(-extent) == 0} {return {}}

    set xm [expr {($x0+$x1)/2.}]
    set ym [expr {($y0+$y1)/2.}]
    set rx [expr {abs($xm-$x0)}]
    set ry [expr {abs($ym-$y0)}]

    set n $V(-sides)
    if {$n == 0} {                              ;# 0 sides => circle
        set n [expr {round(($rx+$ry)*0.5)}]
        if {$n <= 2} {set n 4}
    }

    set dir [expr {$V(-extent) < 0 ? -1 : 1}]   ;# Extent can be negative
    if {abs($V(-extent)) > 360} {
        set V(-extent) [expr {$dir * (abs($V(-extent)) % 360)}]
    }
    set step [expr {$dir * 360.0 / $n}]
    set numsteps [expr {1 + double($V(-extent)) / $step}]

    set xy {}
    set DEG2RAD [expr {acos(-1)*2/360}]

    for {set i 0} {$i < int($numsteps)} {incr i} {
        set rad [expr {($V(-start) - $i * $step) * $DEG2RAD}]
        set x [expr {$rx*cos($rad)}]
        set y [expr {$ry*sin($rad)}]
        lappend xy [expr {$xm + $x}] [expr {$ym - $y}]
    }

    # Figure out where last segment should end
    if {$numsteps != int($numsteps)} {
        # Vecter V1 is last drawn vertext (x,y) from above
        # Vector V2 is the edge of the polygon
        set rad2 [expr {($V(-start) - int($numsteps) * $step) * $DEG2RAD}]
        set x2 [expr {$rx*cos($rad2) - $x}]
        set y2 [expr {$ry*sin($rad2) - $y}]

        # Vector V3 is unit vector in direction we end at
        set rad3 [expr {($V(-start) - $V(-extent)) * $DEG2RAD}]
        set x3 [expr {cos($rad3)}]
        set y3 [expr {sin($rad3)}]

        # Find where V3 crosses V1+V2 => find j s.t.  V1 + kV2 = jV3
        set j [expr {($x*$y2 - $x2*$y) / ($x3*$y2 - $x2*$y3)}]

        lappend xy [expr {$xm + $j * $x3}] [expr {$ym - $j * $y3}]
    }
    return $xy
}
# From https://wiki.tcl-lang.org/CanvasRotation
proc RotateItem {w tagOrId Ox Oy angle} {
    set angle [expr {$angle * atan(1) * 4 / 180.0}] ;# Radians
    foreach id [$w find withtag $tagOrId] {     ;# Do each component separately
        set xy {}
        foreach {x y} [$w coords $id] {
            # rotates vector (Ox,Oy)->(x,y) by angle clockwise

            set x [expr {$x - $Ox}]             ;# Shift to origin
            set y [expr {$y - $Oy}]

            set xx [expr {$x * cos($angle) - $y * sin($angle)}] ;# Rotate
            set yy [expr {$x * sin($angle) + $y * cos($angle)}]

            set xx [expr {$xx + $Ox}]           ;# Shift back
            set yy [expr {$yy + $Oy}]
            lappend xy $xx $yy
        }
        $w coords $id $xy
    }
}
proc About {} {
    set msg "$::S(title)\nby Keith Vetter, February 2008\n$::S(help)"
    tk_messageBox -message $msg -title "About $::S(title)"
}
proc Animate {} {
    after cancel $::S(aid)
    StepIt 1
    if {$::S(animate)} {
        set ::S(aid) [after $::S(delay) Animate]
    }
}
proc StepIt {dir} {
    global S V

    set x1 [lindex [.c bbox peg] 0]
    RotateItem .c peg 0 0 $dir
    set x2 [lindex [.c bbox peg] 0]
    set dx [expr {$x2 - $x1}]
    .c move rod $dx 0
}
DoDisplay
Gears
Rod
Blocks
if {$S(animate)} Animate
return